(*
  Copyright (c) 2009 Barry Schwartz

  Permission is hereby granted, free of charge, to any person
  obtaining a copy of this software and associated documentation
  files (the "Software"), to deal in the Software without
  restriction, including without limitation the rights to use,
  copy, modify, merge, publish, distribute, sublicense, and/or sell
  copies of the Software, and to permit persons to whom the
  Software is furnished to do so, subject to the following
  conditions:

  The above copyright notice and this permission notice shall be
  included in all copies or substantial portions of the Software.

  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
  OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
  NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
  HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
  WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
  FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
  OTHER DEALINGS IN THE SOFTWARE.
*)

open XNum
open Logging
open ParseState
open ALCoding
open ALEnvironment
open ALDim
  
module SymbolMap = SymbolTable.SymbolMap
  
(* gfx-commands *)
let encode_line_cap cap =
  match cap with
  | Graphic.Butt -> VMTypes.Symbol sym_Butt
  | Graphic.Circle -> VMTypes.Symbol sym_Circle
  | Graphic.Square -> VMTypes.Symbol sym_Square
  
let encode_line_join join =
  match join with
  | Graphic.Miter -> VMTypes.Symbol sym_Miter
  | Graphic.Round -> VMTypes.Symbol sym_Round
  | Graphic.Bevel -> VMTypes.Symbol sym_Bevel
  
let encode_gfx_cmd cmd =
  let rec (* FIX *) encode_path path =
    match path with
      | [] -> VMTypes.Nil
      | (ax, ay, bx, by, cx, cy, dx, dy) :: ps ->
          VMTypes.List
            (ref
               (VMTypes.Tuple
                  [| ref (encode_dim_arg ax); ref (encode_dim_arg ay);
                     ref (encode_dim_arg bx); ref (encode_dim_arg by);
                     ref (encode_dim_arg cx); ref (encode_dim_arg cy);
                     ref (encode_dim_arg dx); ref (encode_dim_arg dy)
                  |]),
             ref (encode_path ps))
  in
    match cmd with
      | Graphic.PutBox (x, y, _b) ->
          VMTypes.Tuple
            [| ref (VMTypes.Symbol sym_PutBox); ref (encode_dim_arg x);
               ref (encode_dim_arg y); ref VMTypes.Unbound
            |]
      | Graphic.Draw (pc, p) ->
          let sym =
            (match pc with
               | Graphic.Stroke -> sym_Stroke
               | Graphic.Fill -> sym_Fill
               | Graphic.Clip -> sym_Clip)
          in VMTypes.Tuple [| ref (VMTypes.Symbol sym); ref (encode_path p) |]
      | Graphic.SetColour c ->
          VMTypes.Tuple
            [| ref (VMTypes.Symbol sym_SetColour); ref (encode_colour c) |]
      | Graphic.SetBgColour c ->
          VMTypes.Tuple
            [| ref (VMTypes.Symbol sym_SetBgColour); ref (encode_colour c) |]
      | Graphic.SetAlpha a ->
          VMTypes.Tuple
            [| ref (VMTypes.Symbol sym_SetAlpha); ref (VMTypes.Number a) |]
      | Graphic.SetLineWidth w ->
          VMTypes.Tuple
            [| ref (VMTypes.Symbol sym_SetLineWidth); ref (VMTypes.Number w) |]
      | Graphic.SetLineCap c ->
          VMTypes.Tuple
            [| ref (VMTypes.Symbol sym_SetLineCap); ref (encode_line_cap c) |]
      | Graphic.SetLineJoin j ->
          VMTypes.Tuple
            [| ref (VMTypes.Symbol sym_SetLineJoin); ref (encode_line_join j) |]
      | Graphic.SetMiterLimit l ->
          VMTypes.Tuple
            [| ref (VMTypes.Symbol sym_SetMiterLimit); ref (VMTypes.Number l) |]
  
let decode_line_cap name cap =
  let s = decode_symbol name cap
  in
    if s = sym_Butt
    then Graphic.Butt
    else
      if s = sym_Circle
      then Graphic.Circle
      else
        if s = sym_Square
        then Graphic.Square
        else VMTypes.runtime_error (name ^ ": invalid line cap")
  
let decode_line_join name join =
  let s = decode_symbol name join
  in
    if s = sym_Miter
    then Graphic.Miter
    else
      if s = sym_Round
      then Graphic.Round
      else
        if s = sym_Bevel
        then Graphic.Bevel
        else VMTypes.runtime_error (name ^ ": invalid line join")
  
let decode_gfx_cmd name cmd =
  let rec (* FIX *) decode_path name path =
    List.map
      (fun x ->
         match decode_tuple name x with
         | [| ax; ay; bx; by; cx; cy; dx; dy |] ->
             ((decode_dim_arg name ax), (decode_dim_arg name ay),
              (decode_dim_arg name bx), (decode_dim_arg name by),
              (decode_dim_arg name cx), (decode_dim_arg name cy),
              (decode_dim_arg name dx), (decode_dim_arg name dy))
         | _ -> VMTypes.runtime_error (name ^ ": invalid path segment"))
      (Machine.decode_list name path) in
  let arr = decode_tuple name cmd
  in
    if (Array.length arr) < 1
    then VMTypes.runtime_error (name ^ ": invalid argument")
    else
      (let s = decode_symbol name arr.(0)
       in
         if s = sym_PutBox
         then
           if (Array.length arr) <> 4
           then VMTypes.runtime_error (name ^ ": PutBox expects 3 arguments")
           else
             Graphic.PutBox (decode_dim_arg name arr.(1),
               decode_dim_arg name arr.(2), Box.empty_box)
         else
           if s = sym_Stroke
           then
             if (Array.length arr) <> 2
             then VMTypes.runtime_error (name ^ ": Stroke expects 1 argument")
             else Graphic.Draw (Graphic.Stroke, decode_path name arr.(1))
           else
             if s = sym_Fill
             then
               if (Array.length arr) <> 2
               then VMTypes.runtime_error (name ^ ": Fill expects 1 argument")
               else Graphic.Draw (Graphic.Fill, decode_path name arr.(1))
             else
               if s = sym_Clip
               then
                 if (Array.length arr) <> 2
                 then
                   VMTypes.runtime_error (name ^ ": Fill expects 1 argument")
                 else Graphic.Draw (Graphic.Clip, decode_path name arr.(1))
               else
                 if s = sym_SetColour
                 then
                   if (Array.length arr) <> 2
                   then
                     VMTypes.runtime_error
                       (name ^ ": SetColour expects 1 argument")
                   else Graphic.SetColour (decode_colour name arr.(1))
                 else
                   if s = sym_SetBgColour
                   then
                     if (Array.length arr) <> 2
                     then
                       VMTypes.runtime_error
                         (name ^ ": SetBgColour expects 1 argument")
                     else Graphic.SetBgColour (decode_colour name arr.(1))
                   else
                     if s = sym_SetAlpha
                     then
                       if (Array.length arr) <> 2
                       then
                         VMTypes.runtime_error
                           (name ^ ": SetAlpha expects 1 argument")
                       else
                         Graphic.SetAlpha (Machine.decode_num name arr.(1))
                     else
                       if s = sym_SetLineWidth
                       then
                         if (Array.length arr) <> 2
                         then
                           VMTypes.runtime_error
                             (name ^ ": SetLineWidth expects 1 argument")
                         else
                           Graphic.SetLineWidth
                             (Machine.decode_num name arr.(1))
                       else
                         if s = sym_SetLineCap
                         then
                           if (Array.length arr) <> 2
                           then
                             VMTypes.runtime_error
                               (name ^ ": SetLineCap expects 1 argument")
                           else
                             Graphic.SetLineCap
                               (decode_line_cap name arr.(1))
                         else
                           if s = sym_SetLineJoin
                           then
                             if (Array.length arr) <> 2
                             then
                               VMTypes.runtime_error
                                 (name ^ ": SetLineJoin expects 1 argument")
                             else
                               Graphic.SetLineJoin
                                 (decode_line_join name arr.(1))
                           else
                             if s = sym_SetMiterLimit
                             then
                               if (Array.length arr) <> 2
                               then
                                 VMTypes.runtime_error
                                   (name ^
                                      ": SetMiterLimit expects 1 argument")
                               else
                                 Graphic.SetMiterLimit
                                   (Machine.decode_num name arr.(1))
                             else
                               VMTypes.runtime_error
                                 (name ^ ": invalid graphics command"))
  

